home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CU Amiga Super CD-ROM 19
/
CU Amiga Magazine's Super CD-ROM 19 (1998)(EMAP Images)(GB)[!][issue 1998-02].iso
/
CUCD
/
Utilities
/
Scion
/
ARexx
/
PrintPedigree.rexx
< prev
next >
Wrap
OS/2 REXX Batch file
|
1997-11-04
|
25KB
|
862 lines
/****************************************************************************
* *
* $VER: PrintPedigree 2.08 (25 Nov 1996)
* *
* Written by Freddy Ariës *
* Address: Lindeboomweg 7, NL-7135 KE Harreveld, The Netherlands. *
* *
* Output options: *
* 1. Forefathers (male ancestor line only) [Dutch: stamreeks] *
* 2. Pedigree Chart; no siblings [Dutch: kwartierstaat] *
* 3. Pedigree Chart; only siblings of proband (= of youngest generation) *
* 4. Pedigree Chart; all siblings *
* *
* This script uses (by default) the rexxreqtools.library (which requires *
* a version of reqtools larger than 2.0 and rexxsyslib.library) *
* If you do not have these, run SetDefaults.rexx to change the settings. *
* *
* As of v2 of this script, and Scion V4, the current person on Scion's *
* Personal Window will be used to determine where the search starts. *
* Scion 3.13 can still be used, though, in which case the user will be *
* asked at which IRN he wants to start. *
* *
* So why this PrintPedigree script when Scion already has print options *
* for Ahnentafel/pedigree charts? Well, the reason is simple: the format *
* of the Ahnentafel generated by Scion does not conform to the guidelines *
* of the Dutch CBG (Central Bureau for Genealogy) and NGV (Nederlandse *
* Genealogische Vereniging; Dutch Genealogical Society). So I created my *
* own PrintPedigree script, that *does* follow their guidelines. *
* *
* DONE: *
* - Now uses preference file for default settings *
* - count the number of lines output and give a formfeed after a *
* certain number (ie. skip page breaks) *
* - Inclusion of name/address data from prefs (optional) *
* *
* TO DO (low priority, unless someone really wants this): *
* - add a menu option for the maximum number of generations to print *
* - allow user to specify if he wants burial data, occupation, comments, *
* references fields, etc. printed *
* - option: include empty fields *
* - find a good way to handle sex-fields with value '?' (see below) *
* - include Scion v5 submitter data *
* - Suggestions, comments, bugreports, donations, etc. are appreciated. *
* *
* Known Bugs/Problems: *
* - This script is dog slow for large databases (ie. more than, say, 10 *
* generations), even on Amigas with a Turboboard! *
* - Incorrect assumptions may be made (with regard to father/mother) when *
* there are persons in the database whose sex-field has value '?' *
* *
****************************************************************************/
options failat 20; options results
arg prtin outname noirn mgen outval
versionstr = "2.08"
/* Don't change the settings here! Run SetDefaults.rexx instead! */
usereq = 1; outp = 1; useirn = 1
prtdev = stdout; prtopt = 0; scrdev = stdout
plwidth = 78; pgsize = 0
subf = 0; subm. = ""
PSCR = 'SCIONGEN'
scrname = "CON:0//639//Scion_Output/AUTO/WAIT/CLOSE/SCREEN"
prtrev = 0; /* prtrev = 0 means youngest (first) generation = I */
/* prtrev = 1 means oldest (last) generation = I */
DbtGen = 10;
/* Suggested value for 68000: 10, with Turbo-boards: 12
* From this generation onwards, every additional generation needs a confirm
* Note: 10 generations means (up to) 1024 persons,
* 12 generations means (up to) 4096 persons !!!
*/
pgline = 1
NL = '0A'x
signal on IOERR
/* parse command line options, to allow calling the script automatically,
* eg. from a function key
*/
do while prtin = '?'
Tell("NUMOPT/A/N,OUTFILE/A,NOIRN/S,MAXGEN/N,QUIET/S,NOREQ/S: ")
pull prtin outname noirn mgen outval
end
/* read preferences file */
if open(pfile, 'ENV:Scion/ScionRexx.prefs', 'r') then do
do while ~eof(pfile)
inln = readln(pfile)
if inln ~= "" then do
wstr = upper(word(inln, 1))
select
when wstr = "USEREQ" then
usereq = 1
when wstr = "NOUSEREQ" then
usereq = 0
when wstr = "PUBSCREEN" then
pscr = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
when wstr = "LINEWIDTH" then
do
wstr = word(inln, 2)
if datatype(wstr, 'w') then plwidth = wstr
end
when wstr = "PAGESIZE" then
do
wstr = word(inln, 2)
if datatype(wstr, 'w') then pgsize = wstr
end
when wstr = "SUB_N0" then
subm.0 = delstr(inln, 1, length(wstr)+1)
when wstr = "SUB_A1" then
subm.1 = delstr(inln, 1, length(wstr)+1)
when wstr = "SUB_A2" then
subm.2 = delstr(inln, 1, length(wstr)+1)
when wstr = "SUB_A3" then
subm.3 = delstr(inln, 1, length(wstr)+1)
when wstr = "SUB_T0" then
subm.4 = delstr(inln, 1, length(wstr)+1)
when wstr = "SUB_N1" then
subm.5 = delstr(inln, 1, length(wstr)+1)
when wstr = "SUB_N2" then
subm.6 = delstr(inln, 1, length(wstr)+1)
when wstr = "SUB_N3" then
subm.7 = delstr(inln, 1, length(wstr)+1)
when wstr = "SUB_F0" then
subf = bittst(b2c(strip(delstr(inln, 1, length(wstr)), 'b')), 1)
otherwise
/* unrecognized? skip */
end
end
end
close(pfile)
end
if pscr = "" | (pscr ~= "WORKBENCH" & ~show('p', pscr)) then
pscr = "SCIONGEN"
scrname = scrname||pscr
/* Command line options get priority over global settings */
ParseArguments()
if ~show('l','rexxarplib.library') then do
if exists('libs:rexxarplib.library') then
call addlib('rexxarplib.library',0,-30,0)
end
screentofront(pscr)
if usereq & ~show('l','rexxreqtools.library') then do
if exists('libs:rexxreqtools.library') then
call addlib('rexxreqtools.library',0,-30,0)
else do
usereq = 0; outp = 1
Tell("Unable to open rexxreqtools.library - using text output")
end
end
/* Originally stolen from Peter Billing - thanks Peter ;-) */
if ~show('P','SCIONGEN') then do
EndString('I am sorry to say that the SCION Genealogist' || NL ||,
'database is not available. Please start the' || NL ||,
'SCION program BEFORE using this script!')
end
myport = "SCIONGEN"
address value myport
GETDBNAME
dbname = upper(RESULT)
GETPROGVERSION
progvers = RESULT
if progvers >= 4 then do
GETCURRENTIRN
irn = RESULT
end
if outp & ~usereq then do
if pscr ~= "WORKBENCH" then do
scrdev = 'SCNPEDSCR'
if ~open(scrdev, scrname, 'w') then scrdev = stdout
end
Tell("*** PrintPedigree version "||versionstr||" ***")
Tell("*** by Freddy Ariës ***")
Tell("Current database: "||dbname||NL)
end
if prtopt = 0 then do
/* No use in asking for input if we're not allowed to output anything */
if usereq then do
prtopt = rtezrequest('Current Scion database: '||dbname||NL||,
NL||'Please make your choice: '||,
NL||'1. Forefathers (male ancestor line only)'||,
NL||'2. Pedigree Chart; no siblings'||,
NL||'3. Pedigree Chart; only siblings of proband'||,
NL||'4. Pedigree Chart; all siblings'||,
'',' _1 | _2 | _3 | _4 |E_xit','PrintPedigree v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
if prtopt = 0 then EXIT
if progvers < 4 then do
irn = rtgetlong(,'Enter the IRN of the person whose'||,
NL||'ancestors you want to print: '||,
NL,'Input Request:','_Continue','rt_pubscrname = '||PSCR)
if irn = '' then EndString("No IRN - aborted.")
irn = abs(irn)
end
useirn = rtezrequest('Do you want to output the IRNs'||,
NL||'(the record numbers) as well?'||,
'',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
end
else do
Tell("1. Forefathers (male ancestor line only)")
Tell("2. Pedigree Chart; no siblings")
Tell("3. Pedigree Chart; only siblings of proband")
Tell("4. Pedigree Chart; all siblings")
TellNN("Your choice: ")
prtopt = readln(scrdev)
prtopt = CheckAnswer(word(prtopt,1))
if progvers < 4 then do
TellNN("Enter the IRN of the person whose ancestors you want to print: ")
irn = readln(scrdev)
irn = word(irn, 1)
end
TellNN("Do you want to output the IRN (numbers) as well (y/n)? ")
instr = readln(scrdev)
instr = upper(left(instr, 1))
Tell("")
if instr = "Y" then useirn = 1
else useirn = 0
end
end
if progvers < 4 & ~DATATYPE(irn, 'w') then
EndString("ERROR: Not a valid IRN: "||irn)
EXISTPERSON irn
if RESULT ~= 'YES' then
EndString("No person with IRN "||irn||" in the current database.")
if outp then do
pname = GetNameStr(irn, 0)
if usereq then do
valcont = rtezrequest('The selected person is: '||NL||pname||'.'||,
NL||'Continue?','_Continue| _Abort','PrintPedigree Request:','rt_pubscrname = '||PSCR)
if valcont = 0 then EndString("Aborted.")
end
else do
TellNN("Current person is "||pname||". Continue? (y/n) ")
valcont = readln(scrdev)
valcont = upper(left(valcont, 1))
if valcont ~= 'Y' then EndString("Ok.")
end
end
if outp & outname = "" then do
if usereq then do
odev = rtezrequest('Current Scion database: '||dbname||,
NL||'Where should the output be sent to?'||,
NL,' _File |_Printer|_Screen|_Nowhere','PrintPedigree v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
select
when odev = 1 then do
/* We need a file requester for further data */
dblen = length(dbname)
if dblen>6 & right(dbname, 6)=".SCION" then
dbname=left(dbname, dblen - 6)
outname = rtfilerequest(,dbname||'.PED','Output filename',,'rtfi_buffer = true rt_pubscrname = '||PSCR||' rtfi_initialpath = RAM:',)
if outname = '' then
outname = dbname||'.PED'
end
when odev = 2 then
outname = 'PRT:'
when odev = 3 then
outname = 'STDOUT'
otherwise EndString("No output - aborted.")
/* You selected 'Nowhere' */
end
end
else do
Tell("Enter output file (filename with complete path, or PRT: for printer,")
TellNN("or STDOUT for screen): ")
outname = readln(scrdev)
outname = strip(outname, 'b', ' "')
if outname = "" then outname = 'STDOUT'
end
end
/* Anyone know a better way to translate numbers into Roman? */
GenerationS.1 = "I II III IV V VI VII VIII IX X XI XII XIII XIV XV XVI XVII XVIII XIX XX"
GenerationS.2 = "XXI XXII XXIII XXIV XXV XXVI XXVII XXVIII XXIX XXX XXXI XXXII XXXIII XXXIV XXXV XXXVI XXXVII XXXVIII IXL XL"
/* Printer Codes (some of which are currently unused): */
ESC = '1B'x
prtinit = ESC||"#1"; /* ESC#1 initialize */
prtundon = ESC||"[4m"; /* ESC[4m underline on */
prtundoff = ESC||"[24m"; /* ESC[24m underline off */
prtdson = ESC||"[1m"; /* ESC[1m boldface on */
prtdsoff = ESC||"[22m"; /* ESC[22m boldface off */
prtnlqon = ESC||"[2"||'22'x||"z"; /* ESC[2"z NLQ on */
prtnlqoff = ESC||"[1"||'22'x||"z"; /* ESC[1"z NLQ off */
if ~usereq then
Tell("Building ancestor table...")
currgen = 1; numpers = 1
GENTREE.1 = irn
/* Build the ancestor table */
do until ~foundone
foundone = 0
currgen = currgen + 1
numpers = 2 * numpers
/* = 2 ** (currgen - 1) */
if currgen <= MaxGens then
do
if currgen > DbtGen then
do
if usereq then
do
docont = rtezrequest('Also parse generation '||currgen||' ?'||,
NL||'(this may take *very* long!)'||,
'',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
end
else
do
Tell("Also parse generation '||currgen||' ?' (this may take *very* long!)")
inp = readln(scrdev)
inp = upper(left(inp, 1))
Tell("")
if inp = "Y" then docont = 1
else docont = 0
end
end
else docont = 1
if docont then
do
if prtopt = 1 then
endnum = numpers+1
/* no use to build the entire table, if we need only this little */
else
endnum = 2*numpers-1
/*
* TO DO: at the moment, all the numbers are parsed, even if there
* is only one family group with ancestors in this generation
* This means that thousands of fields may be checked, to find
* two persons. This also makes the program dog slow!
* I must find a better method to do this. Suggestions welcome...
*/
do ct = numpers to endnum by 2
ct1 = ct % 2
irn = GENTREE.ct1
ct1 = ct + 1
GENTREE.ct = 0
GENTREE.ct1 = 0
if irn ~= 0 then do
GETPARENTS irn
fgrn = RESULT
EXISTFAMILY fgrn
if RESULT = 'YES' then do
foundone = 1
GetParentsIRN(fgrn, ct, ct1)
end
end
end
end
end
else do
if usereq then
rtezrequest('Maximum number of'||NL||'generations reached.'||NL||,
NL||'Output truncated','_Continue','PrintPedigree Message:','rt_pubscrname = '||PSCR)
else
Tell("Maximum number of generations reached. Output may be truncated.")
end
end
numgens = currgen - 1
/* Now print all the ancestors */
if ~usereq then
Tell("Printing data...")
OpenPrinter()
if prtopt = 1 then do
/* Forefathers; print only male ancestors */
fill = 7
np = numpers%2
if prtrev then
currgen = currgen - 1
else
currgen = 1
do while np > 1
g1 = GetGenStr(currgen, fill)
ct1 = np + 1
ct2 = np % 2
/* get the husband's data */
g1 = g1||GetPersonStr(GENTREE.np)
GETPARENTS GENTREE.ct2
mf1 = RESULT
EXISTFAMILY mf1
if RESULT = 'YES' then
m1 = GetMarriageStr(mf1)
else
m1 = ""
if m1 ~= "" then do
m1 = g1||", m: "||m1
end
else m1 = g1
g1 = copies(' ',fill)
PrintLines(m1, fill)
/* get the wife's data */
m1 = g1||GetPersonStr(GENTREE.ct1)
PrintLines(m1, fill)
PrintLF()
if prtrev then
currgen = currgen - 1
else
currgen = currgen + 1
np = np % 2
end
g1 = GetGenStr(currgen, fill)||GetPersonStr(GENTREE.np)
g1 = g1||GetMarriages(GENTREE.np)
PrintLines(g1, fill)
PrintLF()
end
else do
/* print all */
if prtrev then
currgen = currgen - 1
else
currgen = 1
fill = 6
g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth-1)
PrintLines(g1, fill)
g1 = "1. "||GetPersonStr(GENTREE.1)
g1 = g1||GetMarriages(GENTREE.1)
PrintLines(g1, fill)
if prtopt > 2 then
PrintSiblings(GENTREE.1, 1)
PrintLF()
np = 2
if prtrev then
currgen = currgen - 1
else
currgen = currgen + 1
do while np < numpers
g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth)
PrintLines(g1, fill)
endnum = 2*np-1
do ct = np to endnum by 2
ct1 = ct + 1
ct2 = ct % 2
/* print the principal data */
if GENTREE.ct ~= 0 then do
g1 = left(ct||". ",fill)||GetPersonStr(GENTREE.ct)
GETPARENTS GENTREE.ct2
mf1 = RESULT
EXISTFAMILY mf1
if RESULT = 'YES' then
m1 = GetMarriageStr(mf1)
else
m1 = ""
if m1 ~= "" then
do
m1 = g1||", m: "||m1
end
else m1 = g1
g1 = copies(' ',fill)
PrintLines(m1, fill)
if prtopt = 4 then
PrintSiblings(GENTREE.ct, ct)
end
/* print the spouse data */
if GENTREE.ct1 ~= 0 then do
m1 = left(ct1||". ",fill)||GetPersonStr(GENTREE.ct1)
PrintLines(m1, fill)
if prtopt = 4 then
PrintSiblings(GENTREE.ct1, ct1)
end
end
PrintLF()
if prtrev then
currgen = currgen - 1
else
currgen = currgen + 1
np = np * 2
end
end
if numgens = 1 then
PrintLines("No ancestors are recorded for this person.", 0)
writech(prtdev, prtnlqoff); /* ESC[1"z NLQ off */
EndString("Done.")
EXIT
/* Parse command line arguments and set the appropriate global variables */
ParseArguments:
if noirn = "NOIRN" then useirn = 0
else if noirn = "QUIET" || noirn = "NOREQ" then do
outval = noirn
noirn = ""
end
else do
outval = mgen
mgen = noirn
noirn = ""
end
if mgen = "QUIET" || mgen = "NOREQ" then do
outval = mgen
mgen = ""
end
MaxGens = 20
/* due to the Roman numbers, we can't handle more than 40 */
/* but due to speed limitations, I don't advise using more than 20 */
if mgen ~= "" then do
if DATATYPE(mgen, 'w') & mgen > 0 & mgen < MaxGens then
MaxGens = mgen
end
if outval = "QUIET" then do
usereq = 0
outp = 0
end
else if outval = "NOREQ" then
usereq = 0
/* if outname = "" then outname = 'STDOUT' */
if prtin = "" then do
prtopt = 0
if ~outp then EndString("Requires argument is missing.")
/* actually, with outp = 0, all it does is EXIT */
end
else do
prtopt = CheckAnswer(prtin)
/* Note that it was important to establish outp before calling these */
end
return 0
OpenPrinter:
/* Open the printer device and print out a nice header */
if outname = 'STDOUT' then do
if ~outp | usereq then do /* output screen wasn't opened yet! */
scrdev = 'SCNPEDSCR'
if ~open(scrdev, scrname, 'w') then scrdev = stdout
end
prtdev = scrdev
end
else do
prtdev = "PRINTER"
if ~open(prtdev, outname, 'w') then
EndString("ERROR: Failed to open output file!")
end
writech(prtdev, prtinit||prtnlqon)
if prtopt = 1 then
prtstr = "FOREFATHERS (Male ancestor line only)"
else if prtopt = 2 then
prtstr = "PEDIGREE CHART; No siblings"
else if prtopt = 3 then
prtstr = "PEDIGREE CHART; Only siblings of proband"
else
prtstr = "PEDIGREE CHART; All siblings"
prtstr = prtundon||prtdson||prtstr||prtdsoff||prtundoff
DoWrite(prtdev, prtstr)
if subf then do
if subm.0 ~= "" then DoWrite(prtdev, subm.0)
if subm.1 ~= "" then DoWrite(prtdev, subm.1)
if subm.2 ~= "" then DoWrite(prtdev, subm.2)
if subm.3 ~= "" then DoWrite(prtdev, subm.3)
if subm.4 ~= "" then DoWrite(prtdev, subm.4)
if subm.5 ~= "" then DoWrite(prtdev, subm.5)
if subm.6 ~= "" then DoWrite(prtdev, subm.6)
if subm.7 ~= "" then DoWrite(prtdev, subm.7)
end
prtstr = prtdson||"Report printed on: "||date()||prtdsoff
DoWrite(prtdev, prtstr)
prtstr = copies('=', plwidth)
DoWrite(prtdev, prtstr)
return 0
PrintLines: PROCEDURE EXPOSE prtdev plwidth prtopt pgline pgsize
parse arg ostr, fill
/* TO DO:
* if there are control strings within ostr (like prtdson or prtdsoff)
* don't include them in the length count
*/
do while ostr ~= ""
nnl = plwidth+1
if length(ostr) > plwidth then do
do until pc = ' ' | nnl = 1
pc = substr(ostr, nnl, 1)
nnl = nnl - 1
end
if nnl = 1 then do
prtstr = left(ostr, plwidth)
ostr = delstr(ostr, 1, nnl)
end
else do
prtstr = left(ostr, nnl)
ostr = delstr(ostr, 1, nnl+1)
end
end
else do
prtstr = ostr
ostr = ""
end
DoWrite(prtdev, prtstr)
if ostr ~= "" then
ostr = copies(' ',fill)||ostr
end
return 0
PrintLF:
DoWrite(prtdev, "")
return 0
PrintSiblings: PROCEDURE EXPOSE prtdev plwidth prtopt useirn pgline pgsize
parse arg inum, prenum
GETPARENTS inum
famfgrn = RESULT
EXISTFAMILY famfgrn
if RESULT ~= 'YES' then return 0; /* no parents, then no siblings */
ix = 0; chnum = 0
do until ischld ~= 'YES'
GETCHILD famfgrn ix
prsn = RESULT
EXISTPERSON prsn
ischld = RESULT
if ischld = 'YES' then do
chnum = chnum + 1
/* skip a number for person <inum> to indicate where he fits in */
if prsn ~= inum then do
ostr = copies(' ',8)||prenum||D2C(chnum+96)". "||GetPersonStr(prsn)
PrintLines(ostr, 11)
if chnum = 26 then return 0; /* 'z': can't handle more than 26 children */
end
end
ix = ix + 1
end
return 0
GetGenStr: PROCEDURE EXPOSE prtopt GenerationS.
parse arg gnum, fill
if gnum <= 20 then
gstr = word(GenerationS.1, gnum)
else if gnum <= 40 then
gstr = word(GenerationS.2, gnum)
else
return "["||gnum||"]"
if prtopt = 1 then gstr = left(gstr||". ",fill)
return gstr
GetPersonStr: PROCEDURE EXPOSE useirn
parse arg irn
if irn ~= 0 then do
nstr = GetNameStr(irn)
nstr = nstr||GetBirthStr(irn)
nstr = nstr||GetDeathStr(irn)
end
else
nstr = "UNKNOWN"
return nstr
GetNameStr: PROCEDURE EXPOSE useirn
parse arg gnum
/* prtdson = '1B'x||"[1m"; * ESC[1m boldface on */
/* prtdsoff = '1B'x||"[22m"; * ESC[22m boldface off */
GETFIRSTNAME gnum
name = RESULT
if name ~= "" then name = name||" "
GETLASTNAME gnum
lname = RESULT
if lname = "" then lname = "UNKNOWN"
name = name||lname
/* another option: name = name||prtdson||lname||prtdsoff
* Problem: see PrintLines
*/
if useirn then name = name||" ["gnum"]"
return name
GetBirthStr: PROCEDURE
parse arg gnum
GETBIRTHPLACE gnum
bstr = RESULT
GETBIRTHDATE gnum
bdat = RESULT
if bdat ~= "" & bstr ~= "" then bstr = bstr||" "
bstr = bstr||bdat
if bstr ~= "" then bstr = ", b: "||bstr
return bstr
GetDeathStr: PROCEDURE
parse arg gnum
GETDEATHPLACE gnum
dstr = RESULT
GETDEATHDATE gnum
ddat = RESULT
if ddat ~= "" & dstr ~= "" then dstr = dstr||" "
dstr = dstr||ddat
if dstr ~= "" then dstr = ", d: "||dstr
return dstr
GetMarriages: PROCEDURE EXPOSE useirn
parse arg irn
mstr = ""
GETMARRIAGE irn 0
mf = RESULT
EXISTFAMILY mf
if RESULT = 'YES' then do
mtrue = 1
GETMARRIAGE irn 1
m2 = RESULT
EXISTFAMILY m2
if RESULT = 'YES' then mset = 1
else mset = 0
end
else
mtrue = 0
mnum = 0
do while mtrue
m1 = GetMarriageStr(mf)
if m1 ~= "" then m1 = m1||' '
ptn = GetPartnerIRN(mf, irn)
m1 = m1||GetPersonStr(ptn)
mnum = mnum + 1
if mset then mstr = mstr||", m("||mnum||"): "||m1
else mstr = mstr||", m: "||m1
GETMARRIAGE irn mnum
mf = RESULT
EXISTFAMILY mf
if RESULT ~= 'YES' then mtrue = 0
end
return mstr
GetMarriageStr: PROCEDURE
parse arg mf
GETMARRYPLACE mf
mstr = RESULT
GETMARRYDATE mf
mdat = RESULT
if mdat ~= "" & mstr ~= "" then mstr = mstr||" "
mstr = mstr||mdat
return mstr
GetParentsIRN: PROCEDURE EXPOSE GENTREE.
parse arg fnum, ct, ct1
fath = 0; moth = 0
GETSPOUSE fnum
sps = RESULT
EXISTPERSON sps
if RESULT = 'YES' then do
GETSEX sps
if RESULT = 'M' then
fath = sps
else moth = sps
end
GETPRINCIPAL fnum
prn = RESULT
/* If there are two mothers, or two fathers, then name the principal
* as 'father' and the spouse as 'mother'
*/
EXISTPERSON prn
if RESULT = 'YES' then do
GETSEX prn
if RESULT = 'M' then do
if fath ~= 0 then
moth = sps
fath = prn
end
else if moth ~= 0 then
fath = prn
else
moth = prn
end
GENTREE.ct = fath
GENTREE.ct1 = moth
return 0
GetPartnerIRN: PROCEDURE
parse arg fnum, inum
GETPRINCIPAL fnum
prn = RESULT
GETSPOUSE fnum
sps = RESULT
if inum = prn then pnum = sps
else if inum = sps then pnum = prn
else pnum = 0
return pnum
CheckAnswer: PROCEDURE EXPOSE outp prtdev usereq scrdev
parse arg str
str = left(str, 1)
if ~DATATYPE(str, 'w') | (str < 1 | str > 4) then
EndString("Invalid option - aborted.")
return str
/*
* output at most #pgsize lines per page to the print device
* if pgsize = 0, this feature is turned off (unlimited #lines per page)
*/
DoWrite: PROCEDURE EXPOSE pgline pgsize
parse arg prtdev, ostr
if pgsize ~= 0 & pgline > pgsize then do
writech(prtdev, '0C'x); /* CTRL-L; next page */
pgline = 0
end
writeln(prtdev, ostr)
pgline = pgline + 1
return 0
Tell: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then
writeln(scrdev, str)
return 0
TellNN: PROCEDURE EXPOSE outp scrdev
/* Tell, No Newline */
parse arg str
if outp then
writech(scrdev, str)
return 0
EndString: PROCEDURE EXPOSE outp prtdev usereq scrdev pscr
parse arg str
/* If you turned off stdout, no error messages will be shown! */
if usereq then
rtezrequest(str,'E_xit','PrintPedigree Message:','rt_pubscrname = '||PSCR)
else do
Tell(str || '0A'x)
end
if outp & ~usereq & (scrdev ~= stdout) then do
Tell("Press <return> to exit.")
readln(scrdev)
close(scrdev)
end
close(prtdev)
EXIT
/* Let's make sure you get a nice message when you turn off the printer :-) */
IOERR:
bline = SIGL
say "I/O error #"||RC||" detected in line "||bline||":"
say sourceline(bline)
EXIT
